home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Lib / inspect-misc.stk < prev    next >
Encoding:
Text File  |  1996-02-22  |  8.9 KB  |  311 lines
  1. ;******************************************************************************
  2. ;
  3. ; Project       : STk-inspect, a graphical debugger for STk
  4. ;
  5. ; File name     : inspect-misc.stk
  6. ; Creation date : Aug-30-1993
  7. ; Last update   : Sep-17-1993
  8. ;
  9. ;******************************************************************************
  10. ;
  11. ; This file contains definitions often used.
  12. ;
  13. ;******************************************************************************
  14.  
  15. (provide "inspect-misc")
  16.  
  17. (define BITMAP_MENU         (& "@" *stk-library* "/bitmaps/menu.bm"))
  18. (define FIXED_FONT         "-adobe-courier-bold-r-*-*-*-140-*-*-*-*-*-*")
  19. (define MEDIUM_FONT         "-adobe-helvetica-medium-r-*-*-*-120-*-*-*-*-*-*")
  20. (define BOLD_FONT         "-adobe-helvetica-bold-r-*-*-*-120-*-*-*-*-*-*")
  21. (define ITALIC-MEDIUM_FONT     "-adobe-helvetica-medium-o-*-*-*-120-*-*-*-*-*-*")
  22.  
  23. (define COURIER_BR14         "-adobe-courier-bold-r-*-*-*-140-*-*-*-*-*-*")
  24. (define HELVETICA_BR12         "-adobe-helvetica-bold-r-*-*-*-120-*-*-*-*-*-*")
  25. (define HELVETICA_BO12         "-adobe-helvetica-bold-o-*-*-*-120-*-*-*-*-*-*")
  26. (define HELVETICA_MR12         "-adobe-helvetica-medium-r-*-*-*-120-*-*-*-*-*-*")
  27. (define HELVETICA_MO12         "-adobe-helvetica-medium-o-*-*-*-120-*-*-*-*-*-*")
  28. (define HELVETICA_MO10         "-adobe-helvetica-medium-o-*-*-*-100-*-*-*-*-*-*")
  29. (define SCREEN_WIDTH        (winfo 'vrootwidth  *root*))
  30. (define SCREEN_HEIGHT        (winfo 'vrootheight *root*))
  31.  
  32.  
  33. ;******************************************************************************
  34. ;
  35. ; General definitions and macros extending STk.
  36. ;
  37. ;******************************************************************************
  38.  
  39. ;---- A special eval
  40. (define (inspect::eval x)
  41.   (if (and (symbol? x) (symbol-bound? x)) (eval x) x))
  42.  
  43. ;---- Predicates
  44.  
  45. (define-macro (not-equal? x y) `(not (equal? ,x ,y)))
  46. (define-macro (different? x y) `(not (equal? ,x ,y)))
  47.  
  48. ;---- Operators
  49.  
  50. (define-macro (<> x y)
  51.   `(not (= ,x ,y)))
  52.  
  53.  
  54. (define (inspect::typeof obj)
  55.   (cond ((boolean? obj)     'boolean)
  56.         ((list? obj)     'list)
  57.         ((pair? obj)     'pair)
  58.         ((symbol? obj)     'symbol)
  59.         ((number? obj)     'number)
  60.         ((char? obj)     'char)
  61.         ((string? obj)     'string)
  62.         ((vector? obj)     'vector)
  63.         ((widget? obj)      'widget) ; must be before since widgets are also closures
  64.         ((closure? obj)     'closure)
  65.     ((primitive? obj) 'primitive)
  66.         (else 'unknown)))
  67.  
  68. ;---- Display
  69.  
  70. (define (write\n . l)
  71.   (until (null? l)
  72.          (write (car l))
  73.          (set! l (cdr l)))
  74.   (newline))
  75.  
  76. (define (display\n . l)
  77.   (until (null? l)
  78.          (display (car l))
  79.          (set! l (cdr l)))
  80.   (newline))
  81.  
  82.  
  83. ;---- Control structures
  84.  
  85. (define-macro (for var test . body)
  86.   `(do ,var
  87.        ((not ,test))
  88.        ,@body))
  89.  
  90. ;---- Strings
  91.  
  92. (define (->string obj)
  93.   (if (widget? obj)
  94.       (widget->string obj)
  95.       (format #f "~A" obj)))
  96.  
  97. (define (->object obj)
  98.   (if (widget? obj)
  99.       (widget->string obj)
  100.       (format #f "~S" obj)))
  101.  
  102. (define (list->str l)
  103.   (if (null? l)
  104.       ""
  105.       (let loop ((l l) (s ""))
  106.         (let ((car-l (car l)) (cdr-l (cdr l)) (elem ()))
  107.           (if (list? car-l)
  108.               (set! elem (string-append "(" (list->str car-l) ")"))
  109.               (set! elem (->string car-l)))
  110.           (if (null? cdr-l)
  111.               (string-append s elem)
  112.               (loop cdr-l (string-append s elem " ")))))))
  113.  
  114. ;---- Vectors
  115.  
  116. (define (vector-index v value)
  117.   (let ((length (vector-length v))
  118.         (index #f))
  119.     (for ((i (- length 1) (- i 1)))
  120.          (>= i 0)
  121.          (if (equal? (vector-ref v i) value) (set! index i)))
  122.     index))
  123.  
  124.  
  125. ;---- Lists
  126.  
  127. (define (list-first obj lst)
  128.   (define (_list-first obj lst index)
  129.     (cond ((null? lst) #f)
  130.           ((equal? obj (car lst)) index)
  131.           (else (_list-first obj (cdr lst) (+ index 1)))))
  132.   (_list-first obj lst 0))
  133.  
  134.  
  135. (define-macro (list-set! lst index value)
  136.   `(begin
  137.      (set! ,lst (list->vector ,lst))
  138.      (vector-set! ,lst ,index ,value)
  139.      (set! ,lst (vector->list ,lst))))
  140.  
  141.  
  142. (define (list-remove obj lst)
  143.   (define (_list-remove obj lst prev-lst)
  144.     (cond ((null? lst) prev-lst)
  145.           ((equal? obj (car lst)) (append prev-lst (cdr lst)))
  146.           (else (_list-remove obj (cdr lst) (append prev-lst
  147.                                                     (list (car lst)))))))
  148.   (_list-remove obj lst ()))
  149.  
  150.  
  151. ;---- Tk goodies
  152.  
  153. (define-macro (widget . etc)
  154.   `(string->widget (& ,@etc)))
  155.  
  156. (define (&& . l)
  157.   (if (null? l)
  158.       ""
  159.       (let loop ((l l) (s ""))
  160.         (if (null? (cdr l))
  161.             (string-append s (->string (car l)))
  162.             (loop (cdr l) (string-append s (->string (car l)) " "))))))
  163.  
  164. (define-macro (tki-get canvas item option)
  165.   `(list-ref (,canvas 'itemconfigure ,item ,option) 2))
  166.  
  167. (define-macro (tki-set canvas item option value)
  168.   `(,canvas 'itemconfigure ,item ,option ,value))
  169.  
  170. (define-macro (@ x y)
  171.   `(& "@" ,x "," ,y))
  172.  
  173. ;******************************************************************************
  174. ;
  175. ; 
  176. ;
  177. ;******************************************************************************
  178.  
  179. (define objects-infos-list ())
  180.  
  181. (define (object-infos obj)  (assoc obj objects-infos-list))
  182. (define (object-type obj)   (list-ref (object-infos obj) 1))
  183. (define (object-symbol obj) (list-ref (object-infos obj) 2))
  184.  
  185. (define (add-object-infos obj)
  186.   (set! objects-infos-list
  187.     (cons (list obj (inspect::typeof obj) (gensym "__g"))
  188.           objects-infos-list)))
  189.  
  190. (define (remove-object-infos obj)
  191.   (set! objects-infos-list
  192.     (list-remove (object-infos obj) objects-infos-list)))
  193.  
  194. (define (find-object-infos key)
  195.   (let ((found #f))
  196.     (do ((l objects-infos-list (cdr l)))
  197.     ((or found (null? l)) found)
  198.       (when (equal? (list-ref (car l) 2) key) 
  199.         (set! found (list-ref (car l) 0))))))
  200.  
  201. (define (detailer-type obj-type)
  202.   (case obj-type
  203.     ((vector pair list) 'VPL)
  204.     ((procedure) 'PROCEDURE)
  205.     ((widget) 'WIDGET)
  206.     (else 'UNKNOWN)))
  207.  
  208. (define (viewer-type obj-type)
  209.   (case obj-type
  210.     ((procedure) 'PROCEDURE)
  211.     ((widget) 'WIDGET)
  212.     (else 'GENERAL)))
  213.  
  214. (define (update-object obj)
  215.   (let* ((obj-val (inspect::eval obj))
  216.      (old-type (object-type obj))
  217.      (obj-type (inspect::typeof obj-val)))
  218.     (unless (equal? old-type obj-type)
  219.         (let ((obj-sym (object-symbol obj)))
  220.           (remove-object-infos obj)
  221.           (set! objects-infos-list
  222.             (cons (list obj obj-type obj-sym) objects-infos-list))))
  223.     (if (inspected? obj) (inspect-display obj))
  224.     (if (detailed? obj)
  225.     (if (equal? (detailer-type old-type) (detailer-type obj-type))
  226.         (detail-display obj)
  227.         (begin
  228.           (undetail obj)
  229.           (if (different? 'UNKNOWN (detailer-type obj-type)) 
  230.           (detail obj)))))
  231.     (if (viewed? obj)
  232.     (if (equal? (viewer-type old-type) (viewer-type obj-type))
  233.         (view-display obj)
  234.         (begin
  235.           (unview obj)
  236.           (view obj))))
  237.     (update 'idletask)))
  238.  
  239. ;---- Undebug
  240.  
  241. (define (undebug)
  242.   (for-each (lambda (obj-infos)
  243.           (let ((obj (car obj-infos)))
  244.         (if (symbol? obj) (untrace-var obj))))
  245.         objects-infos-list)
  246.   (destroy INSPECTOR_WIDGET_NAME)
  247.   (set! inspected-objects-list ())
  248.   (for-each (lambda (obj) (destroy (detail-tl-wid obj))) detailed-objects-list)
  249.   (set! detailed-objects-list ())
  250.   (for-each (lambda (obj) (destroy (view-tl-wid obj))) viewed-objects-list)
  251.   (set! viewed-objects-list ())
  252.   (set! objects-infos-list ()))
  253.  
  254. ;---- id widget
  255.  
  256. (define (create-id-widget str)
  257.   (define wid [frame str])
  258.   (pack [frame (& str ".f1")] :side "top" :fill "x")
  259.   (pack [label (& str ".f1.l1") :anchor "w"] :side "left")
  260.   (pack [label (& str ".f1.l2") 
  261.            :relief "groove" :bd 2 :anchor "w" :font MEDIUM_FONT]
  262.     :fill "x" :expand "yes")
  263.   (pack [frame (& str ".f2")] :side "top" :fill "x")
  264.   (pack [label (& str ".f2.l") :anchor "w"] :side "left")
  265.   (pack [entry (& str ".f2.e") :relief "sunken" :bd 2]
  266.     :fill "x" :expand "yes")
  267.   wid)
  268.  
  269. (define (set-id-label1 wid text width) 
  270.   ((widget wid ".f1.l1") 'config :text text :width width))
  271. (define (set-id-label2 wid text width)
  272.   ((widget wid ".f2.l") 'config :text text :width width))
  273.  
  274. (define (set-id-object wid text) (tk-set! (widget wid ".f1.l2") :text text))
  275. (define (get-id-object wid) (tk-get (widget wid ".f1.l2") :text))
  276. (define (set-id-value wid text)
  277.   ((widget wid ".f2.e") 'delete 0 'end)
  278.   ((widget wid ".f2.e") 'insert 0 text))
  279. (define (get-id-value wid) ((widget wid ".f2.e") 'get))
  280.  
  281.  
  282. ;---- menu widget
  283.  
  284. (define (create-menu-widget str)
  285.   (define wid [frame str :relief "raised" :bd 2])
  286.   (pack [menubutton (& str ".help") :text "Help"] :side "right")
  287.   (tk-set! (widget str ".help") :menu [menu (& str ".help.m")])
  288.   ((widget str ".help.m") 'add 'command :label "STk-inspect"
  289.               :command '(stk:make-help STk-inspect-help))
  290.   wid)
  291.  
  292.  
  293. ;---- toplevel widget
  294.  
  295. (define (create-toplevel-widget str)
  296.   (define wid [toplevel str])
  297.   (pack (create-id-widget (& str ".id")) :side "top" :fill "x" :padx 4 :pady 2)
  298.   (pack (create-menu-widget (& str ".menu"))
  299.     :side "top" :fill "x" :padx 4 :pady 2)
  300.   wid)
  301.  
  302. (define (inspect::shadow-entry e)
  303.   (tk-set! e :state "disabled")
  304.   (tk-set! e :bd 1)
  305.   (tk-set! e :bg "grey50")
  306.   (tk-set! e :fg "grey95"))
  307.   
  308.  
  309. (define (modifiable-object? obj)
  310.   (and (symbol? obj) (symbol-bound? obj) (not (widget? (inspect::eval obj)))))
  311.